home *** CD-ROM | disk | FTP | other *** search
/ Programmer Plus 2007 / Programmer-Plus-2007.iso / Programming / Visual Basic new SourceCode and Projects / Thumbnail Image Browser / Thumbs.bas next >
Encoding:
BASIC Source File  |  2000-02-12  |  9.7 KB  |  231 lines
  1. Attribute VB_Name = "basThumbs"
  2. Option Explicit
  3.  
  4. 'sDefInitFileName is setup as (AppPath\AppEXEName.Ini)
  5. 'and is used as the Default Initialization Filename
  6. Private sDefInitFileName As String
  7.  
  8. ' Maximum long filename path length
  9. Private Const MAX_PATH = 1024
  10.  
  11. 'SendMessage Constants
  12. Private Const BFFM_INITIALIZED = 1
  13. Private Const WM_USER = &H400
  14. Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
  15.  
  16. 'The Following Constants may be passed to BrowseForFolder
  17. 'as vTopFolder or vSelPath
  18. Public Const CSIDL_DESKTOP = &H0    'DeskTop
  19. Public Const CSIDL_PROGRAMS = &H2   'Program Groups Folder
  20. Public Const CSIDL_CONTROLS = &H3   'Control Panel Icons Folder
  21. Public Const CSIDL_PRINTERS = &H4   'Printers Folder
  22. Public Const CSIDL_PERSONAL = &H5   'Documents Folder
  23. Public Const CSIDL_FAVORITES = &H6  'Favorites Folder
  24. Public Const CSIDL_STARTUP = &H7    'Startup Folder
  25. Public Const CSIDL_RECENT = &H8     'Recent folder
  26. Public Const CSIDL_SENDTO = &H9     'SendTo Folder
  27. Public Const CSIDL_BITBUCKET = &HA  'Recycle Bin Folder
  28. Public Const CSIDL_STARTMENU = &HB  'Start Menu Folder
  29. Public Const CSIDL_DESKTOPDIRECTORY = &H10  'Windows\Desktop Folder
  30. Public Const CSIDL_DRIVES = &H11    'Devices Virtual Folder (My Computer)
  31. Public Const CSIDL_NETWORK = &H12   'Network Neighborhood Virtual Folder
  32. Public Const CSIDL_NETHOOD = &H13   'Network Neighborhood Folder
  33. Public Const CSIDL_FONTS = &H14     'Fonts Folder
  34. Public Const CSIDL_TEMPLATES = &H15 'ShellNew folder
  35.  
  36. Private Type SHItemID
  37.     cb      As Long    'Size of the ID (including cb itself)
  38.     abID    As Byte    'The item ID (variable length)
  39. End Type
  40.  
  41. Private Type ItemIDList
  42.     mkid    As SHItemID
  43. End Type
  44.  
  45. Private Type BROWSEINFO
  46.     hOwner          As Long
  47.     pidlRoot        As Long
  48.     pszDisplayName  As String
  49.     lpszTitle       As String
  50.     ulFlags         As Long
  51.     lpCallbackProc  As Long
  52.     lParam          As Long
  53.     iImage          As Long
  54. End Type
  55.  
  56. Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  57. Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
  58. 'Retrieves the location of a special (system) folder.
  59. Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ItemIDList) As Long
  60. 'ParseDisplayName function should be used instead of this undocumented function.
  61. Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
  62. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
  63. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  64. Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
  65. Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
  66.  
  67. Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
  68.     
  69.     Select Case uMsg
  70.         Case BFFM_INITIALIZED
  71.             ' Set the dialog's pre-selected folder using the pidl
  72.             ' set in bi.lParam and passed in the lpData param.
  73.             Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
  74.     
  75.     End Select
  76.  
  77. End Function
  78.  
  79. Public Function BrowseForFolder(hOwnerWnd As Long, Optional ByVal sInstruct As String, Optional vSelPath As Variant, Optional vTopFolder As Variant) As String
  80.  
  81. ' Shows the Browse For Folder dialog
  82. '
  83. ' hOwnerWnd     (Long)                     OwnerWindow.hWnd.
  84. ' sInstruct     (String)                   Instructions for user.
  85. ' vSelPath      (String or CSIDL Constant) Pre-select this Folder.
  86. ' vTopFolder    (String or CSIDL Constant) Set the Top folder.
  87. '
  88. ' If successful, returns the selected folder's full path,
  89. ' returns an empty string otherwise.
  90. '
  91.  
  92. Dim lRet As Long
  93. Dim pidlRet As Long
  94. Dim sPath As String * MAX_PATH
  95. Dim lItemIDList As ItemIDList
  96. Dim uBrowseInfo As BROWSEINFO
  97.     
  98.     With uBrowseInfo
  99.         ' The desktop will own the dialog
  100.         .hOwner = hOwnerWnd
  101.         ' This will be the dialog's root folder.
  102.         If IsMissing(vTopFolder) Then
  103.             vTopFolder = CSIDL_DESKTOP
  104.         End If
  105.         If Len(vTopFolder) > 0 And Not IsNumeric(vTopFolder) Then
  106.             'String Path passed in
  107.             .pidlRoot = SHSimpleIDListFromPath(CStr(vTopFolder))
  108.         Else
  109.             'Long CSIDL Special Folder Constant or Nothing passed in.
  110.             lRet = SHGetSpecialFolderLocation(ByVal hOwnerWnd, ByVal CLng(vTopFolder), lItemIDList)
  111.             .pidlRoot = lItemIDList.mkid.cb
  112.         End If
  113.         ' Set the dialog's prompt string
  114.         .lpszTitle = sInstruct
  115.         ' Obtain and set the address of the callback function
  116.         .lpCallbackProc = FarProc(AddressOf BrowseCallbackProc)
  117.         ' Obtain and set the pidl of the pre-selected folder
  118.         If IsMissing(vSelPath) Then
  119.             'Nothing passed in
  120.             .lParam = .pidlRoot
  121.         ElseIf Len(vSelPath) > 0 And Not IsNumeric(vSelPath) Then
  122.             'String Path passed in
  123.             .lParam = SHSimpleIDListFromPath(CStr(vSelPath))
  124.         Else
  125.             'Long CSIDL Special Folder Constant passed in
  126.             lRet = SHGetSpecialFolderLocation(ByVal hOwnerWnd, ByVal CLng(vSelPath), lItemIDList)
  127.             .lParam = lItemIDList.mkid.cb
  128.         End If
  129.     End With
  130.     
  131.     ' Shows the browse dialog and doesn't return until the dialog is
  132.     ' closed. The BrowseCallbackProc will receive all browse
  133.     ' dialog specific messages while the dialog is open. pidlRet will
  134.     ' contain the pidl of the selected folder if the dialog is not cancelled.
  135.     pidlRet = SHBrowseForFolder(uBrowseInfo)
  136.     
  137.     If pidlRet > 0 Then
  138.         ' Get the path from the selected folder's pidl returned
  139.         ' from the SHBrowseForFolder call (rtns True on success,
  140.         ' sPath must be pre-allocated!)
  141.         If SHGetPathFromIDList(pidlRet, sPath) Then
  142.           ' Return the path
  143.           BrowseForFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1)
  144.         End If
  145.         ' Free the memory the shell allocated for the pidl.
  146.         Call CoTaskMemFree(pidlRet)
  147.     End If
  148.     
  149.     ' Free the memory the shell allocated for the pre-selected folder.
  150.     Call CoTaskMemFree(uBrowseInfo.lParam)
  151.   
  152. End Function
  153.  
  154. Public Function FarProc(lpProcName As Long) As Long
  155.  
  156. 'Returns the value of the AddressOf operator
  157.     
  158.     FarProc = lpProcName
  159.  
  160. End Function
  161.  
  162. Public Function GetInitEntry(ByVal sSection As String, ByVal sKeyName As String, Optional ByVal sDefault As String = "", Optional ByVal sInitFileName As String = "") As String
  163.  
  164. 'This Function Reads In a String From The Init File.
  165. 'Returns Value From Init File or sDefault If No Value Exists.
  166. 'sDefault Defaults to an Empty String ("").
  167. 'Creates and Uses sDefInitFileName (AppPath\AppEXEName.Ini)
  168. 'if sInitFileName Parameter Is Not Passed In.
  169.  
  170. Dim sBuffer As String
  171. Dim sInitFile As String
  172.  
  173.     'If Init Filename NOT Passed In
  174.     If Len(sInitFileName) = 0 Then
  175.         'If Static Init FileName NOT Already Created
  176.         If Len(sDefInitFileName) = 0 Then
  177.             'Create Static Init FileName
  178.             sDefInitFileName = App.Path
  179.             If Right$(sDefInitFileName, 1) <> "\" Then
  180.                 sDefInitFileName = sDefInitFileName & "\"
  181.             End If
  182.             sDefInitFileName = sDefInitFileName & App.EXEName & ".ini"
  183.         End If
  184.         sInitFile = sDefInitFileName
  185.     Else    'If Init Filename Passed In
  186.         sInitFile = sInitFileName
  187.     End If
  188.     
  189.     sBuffer = String$(2048, " ")
  190.     GetInitEntry = Left$(sBuffer, GetPrivateProfileString(sSection, ByVal sKeyName, sDefault, sBuffer, Len(sBuffer), sInitFile))
  191.  
  192. End Function
  193. Public Function SetInitEntry(ByVal sSection As String, Optional ByVal sKeyName As String, Optional ByVal sValue As String, Optional ByVal sInitFileName As String = "") As Long
  194.  
  195. 'This Function Writes a String To The Init File.
  196. 'Returns WritePrivateProfileString Success or Error.
  197. 'Creates and Uses sDefInitFileName (AppPath\AppEXEName.Ini)
  198. 'if sInitFileName Parameter Is Not Passed In.
  199.  
  200. '***** CAUTION *****
  201. 'If sValue is Null then sKeyName is deleted from the Init File.
  202. 'If sKeyName is Null then sSection is deleted from the Init File.
  203.  
  204. Dim sInitFile As String
  205.  
  206.     'If Init Filename NOT Passed In
  207.     If Len(sInitFileName) = 0 Then
  208.         'If Static Init FileName NOT Already Created
  209.         If Len(sDefInitFileName) = 0 Then
  210.             'Create Static Init FileName
  211.             sDefInitFileName = App.Path
  212.             If Right$(sDefInitFileName, 1) <> "\" Then
  213.                 sDefInitFileName = sDefInitFileName & "\"
  214.             End If
  215.             sDefInitFileName = sDefInitFileName & App.EXEName & ".ini"
  216.         End If
  217.         sInitFile = sDefInitFileName
  218.     Else    'If Init Filename Passed In
  219.         sInitFile = sInitFileName
  220.     End If
  221.     
  222.     If Len(sKeyName) > 0 And Len(sValue) > 0 Then
  223.         SetInitEntry = WritePrivateProfileString(sSection, ByVal sKeyName, ByVal sValue, sInitFile)
  224.     ElseIf Len(sKeyName) > 0 Then
  225.         SetInitEntry = WritePrivateProfileString(sSection, ByVal sKeyName, vbNullString, sInitFile)
  226.     Else
  227.         SetInitEntry = WritePrivateProfileString(sSection, vbNullString, vbNullString, sInitFile)
  228.     End If
  229.  
  230. End Function
  231.